(* ===================================================================== *)
(** Outils de travail pour bopprocess
    @Mathieu Barbin *)
(* ===================================================================== *)

(*
#load "unix.cma";;
#load "graphics.cma";;
#load "bplib.cma";;
#load "listMap.cmo";;
*)

open ListMap;;
open Bplib

let index_ligne_net_list = ref 0

(* ===================================================================== *)
(** Les operateurs : (extensible) arite *)
(* ===================================================================== *)
type operator = 
    Unaire of (bool array -> bool array -> unit) (* dest ; op1 *)
  | Binaire of (bool array -> bool array -> bool array -> unit) (* dest ; op1; op2 *)
(* ===================================================================== *)

(* ===================================================================== *)
(** Type du code *)
(* ===================================================================== *)
type code = (int, operator) operation array

and parse_code = (string , string) operation array
    
and ('a,'b) operation = 
  | Input of 'a array
  | Output of 'a array
  | UnaryOperator of ('b * 'a array) (* dest ; op1 ; op2 ..etc..*)
  | BinaryOperator of ('b * 'a array) 
(* ===================================================================== *)

(* ===================================================================== *)
(** Execution d'une operation sous un environnement *)
(* ===================================================================== *)
let exec_operation (env, n) op =
  match op with
  | Input i_tab ->
      begin
	let p = Array.length i_tab in
	let st = input_line stdin in
	try
	  for i = 0 to pred p do
	    BoolArray.load_of_iteri env.(i_tab.(i)) (fun j -> st.[i*n+j] = '1')
	  done
	with
	| _ ->
	    prerr_endline "[!] BopProcess Error : input lengthe";
	    Printf.fprintf stderr "[!] %d bits expected, given : \"%s\"\n" (n * p) st;
	    exit 1
      end
  | Output i_tab -> 
      begin
	let p = Array.length i_tab in
	for i = 0 to pred p do
	  print_string (BoolArray.to_string env.(i_tab.(i)))
	done;
	print_newline ();
	flush stdout
      end
  | UnaryOperator (Unaire f, ops) -> f env.(ops.(0)) env.(ops.(1))
  | BinaryOperator (Binaire f, ops) -> f env.(ops.(0)) env.(ops.(1)) env.(ops.(2))
  | _ -> failwith "verif arity" 
  
(* ===================================================================== *)

(* ===================================================================== *)
(** Execution d'un code sous un environnement *)
(* ===================================================================== *)
let exec_code env code =
  let len = Array.length code in
  while true do
    for i = 0 to pred len do
      exec_operation env code.(i)
    done
  done
(* ===================================================================== *)


(* ===================================================================== *)
(** On depasse max int lors de la creation de fresh name
    (bravo a celui qui a ecrit la net_list) *)  
(* ===================================================================== *)
exception FreshOverflow 
(* ===================================================================== *)

(* ===================================================================== *)
(** Creer une fonction qui creer des freshs, a partir d'une fonction 
    de transformation des entiers *)  
(* ===================================================================== *)
let fresh_fct_factory transf =
  let index = ref (-1) in
  let fresh_name () = 
    begin
      (
       if !index < max_int 
       then incr(index)
       else raise FreshOverflow 
      );
     transf (!index)
    end
  and fresh_init () = index := (-1)
  in (fresh_name,fresh_init)
(* ===================================================================== *)


(* ===================================================================== *)
(** Passer d'un parse code vers un code a partir d'une table de primitive.
    Renvoit le code + env *)
(* ===================================================================== *)
let code_of_parse_code prim n pcode =
  let unknown_prim s =
    Printf.fprintf stderr "[!] bopprocess Error : prim '%s' is not defined\n" s;
    flush stderr;
    exit 1
  and error_prim arite name =
    Printf.fprintf stderr "[!] bopprocess Error : prim '%s' has arity %d\n" name arite;
    flush stderr;
    exit 1
  in
  let fresh, _ = fresh_fct_factory (fun t -> t) in
  let table = ref StringMap.empty in
  let vars = ref IntMap.empty in
  let add_var v id value =
    table := StringMap.add v id (!table);
    vars := IntMap.add id value (!vars)
  in
  let var_map wall v =
    try
      StringMap.find v (!table)
    with
    | Not_found -> 
	begin
	  if is_an_int v 
	  then
	    begin
	      let value = Array.make n false in
	      BoolArray.load_of_int value (int_of_string v);
	      let id = fresh () in
	      add_var v id value;
	      id
	    end
	  else
	    begin
	      if wall
	      then
		begin
		  Printf.fprintf stderr "<!> Warning : Var '%s' is read before assagnment\n" v;
		  flush stderr
		end
	      else ();
	      let value = Array.make n false in
	      let id = fresh () in
	      add_var v id value;
	      id
	    end
	end
  in
  let f_map = function
    | Input s_tab -> Input (Array.map (var_map false) s_tab)
    | Output s_tab -> Output (Array.map (var_map true) s_tab)
    | UnaryOperator (name, ops) ->
	begin
	  try
	    let fp = List.assoc name prim in
	    match fp , Array.length ops with
	    | Unaire _ , 2 -> UnaryOperator (fp, [|var_map false ops.(0); var_map true ops.(1)|])
	    | _ -> error_prim 1 name
	  with
	  | Not_found -> unknown_prim name
	end
    | BinaryOperator (name, ops) ->
	begin
	  try
	    let fp = List.assoc name prim in
	    match fp , Array.length ops with
	    | Binaire _ , 3 -> BinaryOperator (fp, [|var_map false ops.(0); var_map true ops.(1); var_map true ops.(2)|])
	    | _ -> error_prim 2 name
	  with
	  | Not_found -> unknown_prim name
	end
  in
  let code = Array.map f_map pcode in
  let num_vars = fresh () in
  let env = Array.init num_vars (fun i -> IntMap.find i (!vars)) in
  (env, n), code
(* ===================================================================== *)


(* ===================================================================== *)
(** Primitives *)
(* ===================================================================== *)
module Prim =
  struct
    let p_xor dest p q = 
      BoolArray.load_of_iteri dest (fun i -> if p.(i) then not q.(i) else q.(i)) 
	
    let p_or dest p q =
      BoolArray.load_of_iteri dest (fun i -> p.(i) || q.(i))
	 
    let p_and dest p q =
      BoolArray.load_of_iteri dest (fun i -> p.(i) && q.(i))

    let p_add dest p q =
      let i = BoolArray.to_int p
      and j = BoolArray.to_int q in
      BoolArray.load_of_int dest (i+j)

    let p_sub dest p q =
      let i = BoolArray.to_int p
      and j = BoolArray.to_int q in
      BoolArray.load_of_int dest (i-j)

    let prims = 
      [ "^", Binaire p_xor;
	"|", Binaire p_or;
	"\\/", Binaire p_or;	
	"&", Binaire p_and;
	"/\\", Binaire p_and;
	"+", Binaire p_add;
	"-", Binaire p_sub
      ]
  end
(* ===================================================================== *)

(* On procede a un exemple *)

(*

input x, y
t = x /\ y
q = x + t
p = q - 4
output p

*)

(*
let ex01 =
  [|
    Input [|"x"; "y"|];
    BinaryOperator ("/\\", [|"t"; "x"; "y"|]);
    BinaryOperator ("+", [|"q"; "x"; "t"|]);
    BinaryOperator ("-", [|"p"; "q"; "4"|]);
    Output [|"p"|]
  |];;

let ((env,n), code) = code_of_parse_code Prim.prims 4 ex01;; 

exec_operation (env, n) code.(0);;
env;;
exec_code (env, n) code;;
env;;
*)
